perm filename MEXPR.MLI[MLI,LSP] blob
sn#112525 filedate 1975-06-03 generic text, type T, neo UTF8
BEGIN SPECIAL IBASE, !EVALQUOTE, !WARN, !INDENT_LEVEL, BLANK, TAB, DBQUOTE;
DEFINE PRINT_CHECK PREFIX, PRINT_TEST PREFIX;
% ALL FUNCTIONS MUST LEAVE THE POINTER IN THE CORRECT LOCATION FOR THE NEXT FUNCTION TO BEGIN PRINTING. %
EXPR HELP ();
BEGIN
PRINTSTR TERPRI "DO YOU WANT HELP? (Y OR N)";
IF READ() EQ 'Y THEN PRINTSTR "
LISP-TO-MLISP TRANSLATOR
TO CONVERT A LISP FILE TO MLISP, TYPE
(CONVERT FILENAME)
THE ARGUMENT TO `CONVERT' IS SIMILAR TO THE ARGUMENT TO THE LISP1.6
`INPUT' FUNCTION. EXAMPLES:
COMMAND TRANSLATES FILE
(CONVERT DSK: FOO) DSK:FOO
(CONVERT FOO) DSK:FOO
(CONVERT (FOO.BAZ)) DSK:FOO.BAZ
(CONVERT DTA1: FOO) DTA1:FOO
(CONVERT (1,DAV) (FOO.BAZ)) DSK:FOO.BAZ[1,DAV]
FUNCTIONS IN THE FILE SHOULD BE EITHER IN DEFPROP OR DE,DF,DM FORMAT
THE OUTPUT IS PUT ON FILE <FILENAME>.MLI";
INITFN(NIL);
END;
FEXPR CONVERT (FILE);
BEGIN NEW IBASE, !EVALQUOTE, !WARN, !INDENT_LEVEL, FILENAME, X;
IF NULL CDR FILE THEN FILE ← 'DSK: CONS FILE; % DSK: IS THE DEFAULT DEVICE. %
FILENAME ← IF ATOM FILE[2] THEN FILE[2] ELSE FILE[2,1]; % GET THE NAME OF THE FILE. %
EVAL('INPUT CONS FILE); % THE INPUT FILE. %
EVAL <'OUTPUT, 'DSK:, FILENAME CONS 'MLI>; % THE OUTPUT FILE: FILENAME.MLI %
PRINTSTR TERPRI "RADIX FOR NUMBERS IN THE FILE? (8 => OCTAL, 10 => DECIMAL)";
IBASE ← READ();
PRINTSTR TERPRI "IS THE FILE IN EVALQUOTE FORMAT? (Y OR N)";
!EVALQUOTE ← READ() EQ 'Y;
PRINTSTR TERPRI "DO YOU WANT TO BE WARNED ABOUT ILLEGAL MLISP CONSTRUCTIONS? (Y OR N)";
!WARN ← READ() EQ 'Y;
!INDENT_LEVEL ← 0;
CSYM G0000;
TERPRI PRINTSTR TERPRI ("TRANSLATING LISP:"
CAT (IF ATOM FILE[2] THEN FILE[2] ELSE FILENAME CAT "." CAT CDR FILE[2])
CAT " → MLISP:" CAT FILENAME CAT ".MLI");
INC(T,NIL); OUTC(T,NIL);
TERPRI PRINTSTR "BEGIN"; % BEGIN TRANSLATING THE PROGRAM. %
WHILE ¬ATOM X ← ERRSET(READ(), T) DO
IF !EVALQUOTE THEN TOPLEVEL(CAR X CONS READ(), DEFINE_TEST(CAR X)) ELSE TOPLEVEL(CAR X, T);
PRINTSTR "END."; % TRANSLATION COMPLETE. %
INC(NIL,T); OUTC(NIL,T); % RESET THE WORLD. %
RETURN TERPRI 'FINISHED;
END;
% TOPLEVEL FORMATTING FUNCTIONS. %
EXPR TOPLEVEL (X, PRINTSEMI);
% PRINTS A SEMICOLON AND SKIPS LINES AFTER A FUNCTION DEFINITION. %
BEGIN
MEXPR(X);
IF PRINTSEMI THEN TERPRI TERPRI TERPRI PRINT_CHECK ";";
IF ¬ATOM X & CAR X ε '(DEFPROP DE DF DM) THEN PRINTTY(X[2]);
END;
EXPR INDENT (X); % KEEPS TRACK OF THE INDENTATION LEVEL. %
IF X THEN !INDENT_LEVEL ← !INDENT_LEVEL + 1 ELSE !INDENT_LEVEL ← !INDENT_LEVEL - 1;
EXPR INDENTP (X); % MODIFIES THE INDENTATION LEVEL AND INDENTS. %
INDENT(X) PROG2 INPRINT(T);
EXPR INPRINT (TER);
% START A NEW LINE, AND INDENT THE NUMBER OF TABS SPECIFIED BY 'INLEVEL'. %
BEGIN
IF TER THEN TERPRI NIL;
FOR NEW !N←1 TO !INDENT_LEVEL DO PRINT_CHECK TAB; % EACH INDENTATION LEVEL IS 1 TAB. %
END;
% MACRO-EXPANDING FUNCTIONS. %
EXPR EXPAND_MACRO (SEXP);
IF ATOM SEXP | CAR SEXP EQ 'QUOTE THEN SEXP ELSE
IF ISMACRO(CAR SEXP) THEN EXPAND_MACRO(LAMBDA(MAC,S); MAC(S); (GET(CAR SEXP,'MACRO), SEXP))
ELSE EXPAND_MACRO(CAR SEXP) CONS EXPAND_REST(CDR SEXP);
EXPR EXPAND_REST (L);
IF ATOM L THEN L ELSE EXPAND_MACRO(CAR L) CONS EXPAND_REST(CDR L);
% LISP S-EXPRESSION → MLISP M-EXPRESSION %
EXPR MEXPR (SEXP);
IF ATOM SEXP THEN PRINT_ATOM(SEXP, T, T) ELSE % ATOM %
IF ATOM SEXP[1] THEN % (FN ...) %
IF NUMBERP SEXP[1] THEN WARN("CAN'T TRANSLATE A NUMBER USED AS A FUNCTION", SEXP)
ELSE TFN(CAR SEXP, CDR SEXP)
ELSE IF SEXP[1,1] EQ 'LAMBDA THEN TLAMBDA(CDAR SEXP, CDR SEXP) % ((LAMBDA ...) ...) %
ELSE BEGIN NEW G; % ((FN ...) ...) %
G ← GENSYM();
MEXPR(<<'LAMBDA, <G>, G CONS CDR SEXP>, CAR SEXP>);
END;
% TRANSLATE FUNCTION DEFINITIONS. %
EXPR TDEFPROP (FN, ARGS);
BEGIN
IF ARGS[3] ε '(MACRO ?*FEXPR) THEN PUTPROP(ARGS[1], ARGS[2], ARGS[3]);
IF ARGS[3] ε '(EXPR FEXPR LEXPR MACRO) THEN
BEGIN
IF ARGS[3] EQ 'FEXPR THEN PUTPROP(ARGS[1], T, '?*FEXPR);
PRINT_CHECK ARGS[3];
PRINT_CHECK " ";
PRINT_ATOM(ARGS[1], T, T);
PRINT_CHECK " (";
TARGS(IF ARGS[3] EQ 'LEXPR THEN <ARGS[2,2]> ELSE ARGS[2,2], ", ");
PRINT_CHECK ");";
INDENTP(T);
MEXPR(ARGS[2,3]);
INDENT(NIL);
END
ELSE MEXPR(<'EVAL, <'QUOTE, 'DEFPROP CONS ARGS>>);
END;
EXPR TDE (FN, ARGS);
MEXPR(<'DEFPROP, CAR ARGS, <'LAMBDA,ARGS[2],ARGS[3]>, GET(FN,'FTYPE)>);
EXPR TDEFINE (FN, ARGS);
FOR NEW DEF IN ARGS[1] DO TOPLEVEL(<'DEFPROP, DEF[1], DEF[2], GET(FN,'FTYPE)>, T);
% TRANSLATE PROG'S INTO BEGIN-END BLOCKS. %
EXPR TPROG (FN, ARGS);
BEGIN NEW CHRS;
PRINT_CHECK "BEGIN";
IF CAR ARGS THEN % FIRST TRANSLATE THE PROG VARIABLES. %
BEGIN
INPRINT(T);
PRINT_CHECK "NEW ";
TARGS(CAR ARGS, ", ");
PRINT_CHECK ";";
END;
TERPRI NIL;
CHRS ← 0;
FOR NEW S IN CDR ARGS DO % TRANSLATE EACH STATEMENT IN THE PROG. %
IF ATOM S THEN
BEGIN % A LABEL. %
INDENT(NIL);
IF CHRS = 0 THEN INPRINT(NIL);
PRINT_ATOM(S, T, T);
PRINT_CHECK "; ";
INDENT(T);
CHRS ← FLATSIZE(S) + 2;
END
ELSE BEGIN % NOT A LABEL. %
IF CHRS = 0 THEN INPRINT(NIL) ELSE PRINT_CHECK TAB;
MEXPR(S);
TERPRI PRINT_CHECK ";";
CHRS ← 0;
END;
INPRINT(NIL);
PRINT_CHECK "END";
END;
% TRANSLATE COND'S INTO IF-THEN-ELSE. %
EXPR TCOND (FN, ARGS);
% ARGS = ((P1 E11 E12 ...) (P2 E21 E22 ...) ... (Pn En1 En2 ...)) %
FOR NEW L ON ARGS DO
BEGIN NEW SEXP, SYM;
SEXP ← IF CDR L[1] THEN L[1] ELSE <<'SETQ, SYM ← GENSYM(), L[1,1]>, SYM>;
IF SEXP[1] EQ 'T & ¬CDR L THEN RETURN TCOND1(CDR SEXP, NIL, NIL); % ELSE CASE %
PRINT_CHECK "IF ";
MEXPR(SEXP[1]);
PRINT_CHECK " THEN ";
TCOND1(CDR SEXP, T, NIL);
IF CDR L THEN INPRINT(T) ALSO PRINT_CHECK "ELSE ";
END;
EXPR TCOND1 (EXPRS, NEWLINE, ALSOS);
FOR NEW L ON EXPRS DO
BEGIN NEW S, P, N;
S ← ISSPECIAL(L[1]);
N ← NEWLINE & (S | FLATSIZE L[1] ≥ CHRCT());
P ← CDR L & ISCOND(L[1]) | INCOMPLETE_COND(L[1]);
IF N THEN INDENTP(T)
ELSE IF S THEN INDENT(T) ALSO PRINT_CHECK TAB;
IF P THEN PRINT_CHECK "(";
MEXPR(L[1]);
IF P THEN PRINT_CHECK ")";
IF N | S THEN INDENT(NIL);
IF ALSOS THEN INDENT(NIL);
IF CDR L THEN
BEGIN
INDENTP(T);
PRINT_CHECK "ALSO ";
ALSOS ← T;
END;
NEWLINE ← NIL;
END;
EXPR ISCOND (SEXP);
¬ATOM SEXP & (SEXP[1] EQ 'COND | SEXP[1] EQ 'SETQ & ISCOND(SEXP[3]));
EXPR INCOMPLETE_COND (SEXP);
¬ATOM SEXP & (SEXP[1] EQ 'COND & (LAST SEXP)[1,1] NEQ 'T | SEXP[1] EQ 'SETQ & INCOMPLETE_COND(SEXP[3]));
% TRANSLATE FUNCTION CALLS %
EXPR TFN (FN, ARGS); % (FN E1 E2 ... En) → FN(E1, E2, ..., En) %
IF ISMACRO(FN) THEN MEXPR(EXPAND_MACRO(FN CONS ARGS))
ELSE IF GET(FN,'SPECIALFN) THEN
BEGIN NEW FUN;
FUN ← GET(FN,'SPECIALFN);
FUN(FN, ARGS);
END
ELSE IF FN EQ 'QUOTE THEN TQUOTE(CAR ARGS)
ELSE IF FN EQ 'LIST THEN TLIST(ARGS)
ELSE IF ISINDEX(FN, ARGS) THEN TINDEX(FN CONS ARGS)
ELSE IF ISNEQ(FN, ARGS) THEN MEXPR(AT("N" CAT ARGS[1,1]) CONS CDAR ARGS)
ELSE IF ISPREFIX(FN, ARGS) THEN TPREFIX(FN, ARGS)
ELSE IF ISINFIX(FN, ARGS) THEN TINFIX(FN, ARGS)
ELSE IF ISFEXPR(FN) & ARGS & FN NEQ 'FUNCTION THEN MEXPR(<'EVAL, <'QUOTE, FN CONS ARGS>>)
ELSE BEGIN
PRINT_ATOM(FN, T, NIL);
PRINT_CHECK "(";
TARGS(ARGS, ", ");
PRINT_CHECK ")";
END;
EXPR TARGS (ARGS, S); % (E1 E2 ... En) → E1, E2, ..., En %
IF ARGS THEN
BEGIN
TARG(CAR ARGS);
FOR NEW I IN CDR ARGS DO PRINT_CHECK S PROG2 TARG(I);
END;
EXPR TARG (SEXP);
IF ISSPECIAL(SEXP) THEN
BEGIN NEW N;
INDENT(T);
IF (N ← LINELENGTH(NIL) - !INDENT_LEVEL*8) LESSP CHRCT() THEN PRINT_CHECK TAB
ELSE IF N = CHRCT() THEN NIL
ELSE INPRINT(T);
MEXPR(SEXP);
INDENT(NIL);
END
ELSE MEXPR(SEXP);
EXPR TLAMBDA (FN, ARGS); % THIS TRANSLATES LAMBDA EXPRESSIONS. %
BEGIN
IF FN EQ 'LAMBDA THEN FN ← ARGS ALSO ARGS ← NIL; % LAMBDA WITH NO ACTUAL ARGUMENTS. %
PRINT_CHECK "LAMBDA (";
TARGS(FN[1], ", "); % THE FORMAL ARGUMENTS %
PRINT_CHECK "); ";
IF ARGS THEN
BEGIN
INDENTP(T);
MEXPR(FN[2]); % THE LAMBDA BODY. %
PRINT_CHECK ";";
INDENTP(NIL);
PRINT_CHECK "(";
TARGS(ARGS, ", "); % THE ACTUAL ARGUMENTS. %
PRINT_CHECK ")";
END
ELSE MEXPR(FN[2]);
END;
EXPR TPREFIX (FN, ARGS); % (FN E1) → FN E1 %
BEGIN NEW P;
P ← PAREN_TEST(CAR ARGS);
IF GET(FN,'ABBREV) THEN PRINT_CHECK GET(FN,'ABBREV)
ELSE PRINT_CHECK FN ALSO PRINT_CHECK BLANK;
IF P THEN PRINT_CHECK "(";
TARG(CAR ARGS);
IF P THEN PRINT_CHECK ")";
END;
EXPR TINFIX (FN, ARGS);
BEGIN NEW P;
P ← INFIX_TEST(FN, ARGS[1], '?&LEFT, '?&RIGHT);
IF P THEN PRINT_CHECK "(";
TARG(ARGS[1]);
IF P THEN PRINT_CHECK ")";
PRINT_CHECK BLANK;
IF GET(FN,'ABBREV) THEN PRINT_CHECK GET(FN,'ABBREV) ELSE PRINT_ATOM(FN, T, T);
PRINT_CHECK BLANK;
IF LENGTH ARGS ≥ 3 THEN RETURN MEXPR(FN CONS CDR ARGS);
P ← INFIX_TEST(FN, ARGS[2], '?&RIGHT, '?&LEFT);
IF P THEN PRINT_CHECK "(";
TARG(ARGS[2]);
IF P THEN PRINT_CHECK ")";
END;
EXPR TINDEX (SEXP); % (CADR L) → L[2], (CADDDR (CDDADR L)) → L[2,6], ETC. %
BEGIN NEW L,P;
WHILE ¬ATOM SEXP & ISCARCDR(CAR SEXP) DO
BEGIN
L ← L @ CDR EXPLODEC CAR SEXP;
SEXP ← SEXP[2]
END;
P ← PAREN_TEST(SEXP) | ¬ATOM SEXP & ISPREFIX(CAR SEXP, CDR SEXP);
IF P THEN PRINT_CHECK "(";
TARG(SEXP);
IF P THEN PRINT_CHECK ")";
PRINT_CHECK "[";
TARGS(INDEX_LIST(L, NIL), ",");
PRINT_CHECK "]"
END;
EXPR INDEX_LIST (L, IL);
IF NULL L THEN IL
ELSE INDEX_LIST(CDR L,
IF CAR L EQ 'A THEN 1 CONS IL
ELSE IF CAR L EQ 'D THEN CAR IL + 1 CONS CDR IL
ELSE IL);
EXPR TLIST (ARGS); % (LIST E1 E2 ... En) → <E1, E2, ..., En> %
BEGIN
PRINT_CHECK "<";
TARGS(ARGS, ", ");
PRINT_CHECK ">";
END;
EXPR TQUOTE (SEXP);
IF STRP SEXP THEN PRINT_TEST SEXP ALSO PRIN1 SEXP % (QUOTE "...") → "..." %
ELSE PRINT_CHECK "'" ALSO PRINT_SEXP(SEXP, NIL, NIL); % (QUOTE EX) → 'EX %
% TEST FUNCTIONS. %
EXPR ISPREFIX (FN, ARGS); GET1(FN,'?&PREFIX) & LENGTH ARGS = 1;
EXPR ISINFIX (FN, ARGS); GET1(FN,'?&RIGHT) & LENGTH ARGS = 2 | GET1(FN,'ABBREV) & LENGTH ARGS ≥ 2;
EXPR ISSPECIAL (S); ¬ATOM S & (¬ATOM S[1] | GET1(S[1],'SPECIALFN));
EXPR DEFINE_TEST (FN); ¬(FN ε '(DEFINE DEFEXPR MACRO));
EXPR ISFEXPR (FN); GET1(FN,'FEXPR) | GET1(FN,'FSUBR) | GET1(FN,'?*FEXPR);
EXPR PAREN_TEST (S); ISSPECIAL(S) | ¬ATOM S & ISINFIX(CAR S, CDR S);
EXPR ISNEQ (FN, ARGS); FN EQ 'NOT & ¬ATOM ARGS[1] & ARGS[1,1] ε '(EQ EQUAL);
EXPR ISCARCDR (FN); GET1(FN,'CARCDR);
EXPR ISMACRO (FN); GET1(FN,'MACRO);
EXPR ISINDEX (FN, ARGS);
ISCARCDR(FN) & (EXPLODEC FN)[2] EQ 'A & (FLATSIZE FN ≥ 4 | ¬ATOM ARGS[1] & ISCARCDR(ARGS[1,1]));
EXPR INFIX_TEST (FN, A, IND1, IND2);
ISSPECIAL(A) & BINDINGPOWER(FN, IND1) ≠ 0
| ¬ATOM A & ISINFIX(CAR A, CDR A) & BINDINGPOWER(FN, IND1) ≥ BINDINGPOWER(CAR A, IND2);
EXPR GET1 (A, IND); IF ATOM A & ¬NUMBERP A THEN GET(A,IND);
EXPR BINDINGPOWER (X, IND);
IF X ← GET1(X,IND) THEN X ELSE GET('?&DEFAULT, IND);
% PRINT ROUTINES. %
EXPR PRINT_SEXP (SEXP, RWARN, PWARN);
% THIS CONVERTS LISP S-EXPRESSIONS INTO MLISP S-EXPRESSIONS (CONTAINING ONLY MLISP ATOMS). %
IF ATOM SEXP THEN PRINT_ATOM(SEXP, RWARN, PWARN)
ELSE BEGIN
PRINT_CHECK "(";
PRINT_SEXP(CAR SEXP, RWARN, PWARN);
PRINT_SEXP1(CDR SEXP, RWARN, PWARN);
PRINT_CHECK ")";
END;
EXPR PRINT_SEXP1 (L, RWARN, PWARN);
IF NULL L THEN NIL
ELSE IF ATOM L THEN PRINT_CHECK " . " ALSO PRINT_ATOM(L, RWARN, PWARN)
ELSE BEGIN
PRINT_CHECK BLANK;
PRINT_SEXP(CAR L, RWARN, PWARN);
PRINT_SEXP1(CDR L, RWARN, PWARN);
END;
EXPR PRINT_ATOM (A, RWARN, PWARN);
% MAKES SURE EVERY ATOM PRINTED IS A LEGAL MLISP ATOM. %
IF NUMBERP A THEN PRINT_CHECK A
ELSE BEGIN NEW MLISP_ATOM;
MLISP_ATOM ← FOR NEW I IN EXPLODEC A COLLECT
IF NUMBERP I | GET(I,'LETTER) THEN <I> ELSE <'??,I>;
IF LENGTH MLISP_ATOM ≥ CHRCT() THEN INPRINT(T) ALSO PRINT_CHECK TAB;
FOR NEW I IN MLISP_ATOM DO PRINC I; % ONE OF 2 PLACES 'PRINC' IS EXPLICITLY USED. %
IF RWARN & GET(A,'?&RESWORD) THEN WARN("MLISP RESERVED WORD", A)
ELSE IF PWARN & GET(A,'?&PREFIX) THEN WARN("MLISP PREFIX NOT USED AS A PREFIX", A);
END;
EXPR PRINT_CHECK (X); % ONE OF 2 PLACES 'PRINC' IS EXPLICITLY USED. %
PRINT_TEST(X) PROG2 PRINC X;
EXPR PRINT_TEST (X);
IF FLATSIZE X ≥ CHRCT() THEN INPRINT(T) ALSO PRINT_CHECK TAB;
EXPR WARN (MSG, X);
IF !WARN THEN
BEGIN NEW N; SPECIAL !N;
N ← CHRCT();
PRINC TERPRI("*** WARNING, " CAT MSG CAT ": ");
TERPRI PRINC X;
FOR NEW !N←1 TO CHRCT() - N DO PRINC BLANK;
END;
% INITIALIZATION. %
FOR NEW I IN '(
(( (PLUS ?+) (?*PLUS ?+) (DIFFERENCE ?-) (?*DIF ?-) (TIMES ?*) (?*TIMES ?*) (QUOTIENT ?/) (?*QUO ?/)
(PRELIST ?↑) (SUFLIST ?↓) (APPEND ?@) (MEMBER ?ε) (SETQ ?←) (STORE ?←) (NOT ?¬)
(AND ?&) (OR ?|) (EQUAL ?=) (NEQUAL ?≠) (LEQUAL ?≤) (GEQUAL ?≥)) . ABBREV)
(( (DE EXPR)
(DF FEXPR)
(DM MACRO)
%(DEFINE EXPR)%
%(DEFEXPR FEXPR)%
%(MACRO MACRO)%) . FTYPE)
(( (DEFPROP TDEFPROP)
(DE TDE)
(DF TDE)
(DM TDE)
(LAMBDA TLAMBDA)
(PROG TPROG)
(COND TCOND)
%(DEFINE TDEFINE)%
%(DEFEXPR TDEFINE)%
%(MACRO TDEFINE)%) . SPECIALFN)) DO
FOR NEW J IN CAR I DO PUTPROP(J[1], J[2], CDR I);
FOR NEW I IN '(
((A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
a b c d e f g h i j k l m n o p q r s t u v w x y z ?_ ?: ?!) . LETTER)
((CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CDAAR CADDR CDADR CDDAR CDDDR
CAAAAR CAAADR CAADAR CADAAR CDAAAR CAADDR CADADR CDAADR CDADAR CDDAAR CADDAR
CADDDR CDADDR CDDADR CDDDAR CDDDDR) . CARCDR)) DO
FOR NEW J IN CAR I DO PUTPROP(J, T, CDR I);
IBASE ← 8;
EVAL '(DSKIN (S,DAV) MINIT); % READ IN THE FILE 'MINIT' FOR MORE INITIALIZATION. %
IBASE ← 10;
REMOB(INIT1, INIT2);
REMPROP('QUOTE,'?&PREFIX);
REMPROP('FUNCTION,'?&PREFIX);
REMPROP('DEFSYM, 'MACRO);
INITFN('HELP);
END.